home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / HELP language 1.4 / Help Files / ATMS / • v 1.5 (atms) next >
Encoding:
Text File  |  1991-02-18  |  21.0 KB  |  500 lines  |  [TEXT/Help]
  1. {differences avec v1.5: Toutes les feuilles d'échec}
  2.  
  3. (warn ƒ
  4.   
  5. (define (just l)
  6.   (warn () (raz))
  7.   (let [(ls&ns (creer…ls&ns l 0))]
  8.        (define *ts* (apply cell (0 ls&ns)))
  9.        (define *ns* (1 ls&ns))
  10.        (just…*tc* l)))
  11.  
  12. (define (just…*tc* l)
  13.   (let [(lc&nsmax (creer…lc&nsmax l 0))]
  14.        (define *tc* (apply cell (0 lc&nsmax)))
  15.        (define *nc* (1- (blength *tc*)))
  16.        (define *nsmax* (1 lc&nsmax))
  17.        (just…*tc/s&*tc/nxx* l)))
  18.  
  19. (define (just…*tc/s&*tc/nxx* l)
  20.   (letrec [((init…tc/s i t)
  21.             (cond (>? i *ns*) t
  22.                   (begin (cell=! t i (cell (makebitarray *nc*)(makebitarray *nc*)))
  23.                          (init…tc/s (1+ i) t))))
  24.            ((init…tc/nxx i t)
  25.             (cond (>? i *nsmax*) t
  26.                   (begin (cell=! t i (makebitarray *nc*))
  27.                          (init…tc/nxx (1+ i) t))))
  28.            (tc/s&tc/nxx (creer…tc/s&tc/nxx 0 (init…tc/s 0 (makecell (1+ *ns*) 0))
  29.                                              (init…tc/nxx 0 (makecell (+ *nsmax* 1) 0))
  30.                                              (init…tc/nxx 0 (makecell (+ *nsmax* 1) 0))))
  31.            (tc…s-> (bitand (1 (1 tc/s&tc/nxx)) (0 (2 tc/s&tc/nxx))))
  32.            (tc…->s (bitand (0 (1 tc/s&tc/nxx)) (1 (2 tc/s&tc/nxx))))]
  33.           (define *tc/s* (0 tc/s&tc/nxx))
  34.           (define *msk* (bitnot! (makebitarray *nc*)))
  35.           (define *a->b* (avancer…pg!ts (trouver…ts! pd (bitfind tc…->s) tc…->s)
  36.                                         (1 tc/s&tc/nxx) (2 tc/s&tc/nxx) *msk*
  37.                                         (avancer…pd!ts (trouver…ts! pg (bitfind tc…s->) tc…s->)
  38.                                                        (1 tc/s&tc/nxx) (2 tc/s&tc/nxx) *msk*
  39.                                                        (cell (makebitarray *ns*) (makebitarray *ns*)))))
  40.           (accede *a->b*)
  41.           (define *tc/nsg* (1 tc/s&tc/nxx))
  42.           (define *tc/nsd* (2 tc/s&tc/nxx))))
  43.  
  44. (define (creer…ls&ns lc n)
  45.   (cond (null? lc) (cell () n)
  46.         (letrec [((loop ls n l&n)
  47.                   (cond (null? ls) (cell n l&n)
  48.                         (let [(s (intern 'dk (0 ls)))]
  49.                              (cond (warn () (error? (binding=? s ())))
  50.                                    (begin (binding=! s () n)
  51.                                           (let [(etc (loop (-1 ls) (1+ n) l&n))]
  52.                                                (cell (0 etc) (cell (cons (0 ls) (0 (1 etc))) (1 (1 etc))))))
  53.                                    (loop (-1 ls) n l&n)))))
  54.                  (respg (loop (pg (0 lc)) n
  55.                               (letrec [(respd (loop (pd (0 lc)) (0 respg)
  56.                                                     (creer…ls&ns (-1 lc) (0 respd))))]
  57.                                       (1 respd))))]
  58.                 (1 respg))))
  59.  
  60. (define (creer…lc&nsmax l old…nsmax)
  61.   (cond (null? l) (cell () old…nsmax)
  62.                   (letrec [(dabordpg (traduire (pg (0 l)) (makebitarray *ns*)))
  63.                            (dabordpd (traduire (pd (0 l)) (makebitarray *ns*)))
  64.                            (nsmax (max (bitcount dabordpg) (bitcount dabordpd) old…nsmax))
  65.                            (etc (creer…lc&nsmax (-1 l) nsmax))]
  66.                           (cond (bitfind (bitand dabordpg dabordpd))
  67.                                 etc
  68.                                 (cell (consminimal (cell dabordpg dabordpd) (0 etc)) (1 etc))))))
  69.  
  70. (define (creer…tc/s&tc/nxx i tc/s tc/nsg tc/nsd)
  71.   (cond (=? i *nc*) (cell tc/s tc/nsg tc/nsd)
  72.                     (letrec [(lhs (bcopy (pg (i *tc*))))
  73.                              (rhs (bcopy (pd (i *tc*))))
  74.                              (nlhs (bitcount lhs))
  75.                              (nrhs (bitcount rhs))]
  76.                             (bitset! (nlhs tc/nsg) i)
  77.                             (bitset! (nrhs tc/nsd) i)
  78.                             (cond (not (zero? nlhs))
  79.                                   (remplir…tc/s pg (bitfind lhs) lhs i tc/s)
  80.                                   (bitset! (pg (*ns* tc/s)) i))
  81.                             (cond (not (zero? nrhs))
  82.                                   (remplir…tc/s pd (bitfind rhs) rhs i tc/s)
  83.                                   (bitset! (pd (*ns* tc/s)) i))
  84.                             (creer…tc/s&tc/nxx (1+ i) tc/s tc/nsg tc/nsd))))
  85.  
  86. {••• Traduit une liste de symboles en un vecteur de bits en fonction du package dk}
  87.  
  88. (define (traduire l ba)
  89.   (cond (null? l) ba
  90.         (bitset! (traduire (-1 l) ba) (binding=? (intern 'dk (0 l)) ()))))
  91.  
  92. {••• Ajoute une clause dans une liste de clauses avec verification des soussommages: Tres long
  93.      *tc* se retrouve dans l'ordre inverse par rapport a la liste initiale}
  94.  
  95. (define (consminimal c lc)
  96.   (cond (null? lc) (list c)
  97.         (let [(interpg (bitand (pg (0 lc)) (pg c)))
  98.               (interpd (bitand (pd (0 lc)) (pd c)))]
  99.              (cond (and (=? interpg (pg (0 lc))) (=? interpd (pd (0 lc)))) lc
  100.                    (and (=? interpg (pg c)) (=? interpd (pd c))) (consminimal c (-1 lc))
  101.                    (cons (0 lc) (consminimal c (-1 lc)))))))
  102.  
  103. {••• … ou sans verification des soussommages
  104.      *tc* se retrouve dans l'ordre par rapport a la liste initiale}
  105.  
  106. (define consminimal cons)
  107.  
  108. {••• Allume le bit i dans les bitarrays de tc/s pour chaque symbole dans p}
  109.  
  110. (define (remplir…tc/s goud rang p i tc/s)
  111.   (cond rang (begin (bitset! (goud (rang tc/s)) i)
  112.                     (bitclr! p rang)
  113.                     (remplir…tc/s goud (bitfind p) p i tc/s))))
  114.  
  115. {••• Affecte ? aux *ns* symboles de *ts* dans le package dk}
  116.  
  117. (define (raz)
  118.   (cond (error? *ts*) †
  119.         (letrec [(ns (1- (blength *ts*)))
  120.                  ((loop n)
  121.                   (cond (=? n ns) †
  122.                         (begin (binding=! (intern 'dk (n *ts*)) () '?)
  123.                                (loop (1+ n)))))]
  124.                 (loop 0))))
  125.  
  126. {••• Extraordinaire barriere d'abstraction: pg partie gauche et pd partie droite}
  127.  
  128. (define pg 0)
  129. (define pd 1)
  130.  
  131. {•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••}
  132.  
  133. (define (• lhs rhs)
  134.   (letrec
  135.    [(a (traduire lhs (makebitarray *ns*)))
  136.     (b (traduire rhs (makebitarray *ns*)))
  137.     (msk (bcopy *msk*))
  138.     (tc/nsg (bcopy *tc/nsg*))
  139.     (tc/nsd (bcopy *tc/nsd*))
  140.     (a->b (avancer…pg!ts a tc/nsg tc/nsd msk (avancer…pd!ts b tc/nsg tc/nsd msk (ccopy *a->b*))))
  141.     (rangtt (explorer tc/nsg tc/nsd msk))]
  142.    (cond (eq? a->b †) ()
  143.          (and (bitfind (0 tc/nsd)) rangtt)
  144.          (begin {(prin (ppc rangtt)) (pause)}
  145.                 (prouver…ts 1 (bitmsk (pg (rangtt *tc*)) (pg a->b)) tc/nsg tc/nsd msk a->b))
  146.          ())))
  147.  
  148.  
  149. {•••prouve les clauses a->gb pour tout g de gamma}
  150.  
  151. (define (prouver…ts niveau gamma old…tc/nsg old…tc/nsd old…msk old…a->b)
  152.   (letrec [(rang (bitfind gamma))
  153.            (tc/nsg (bcopy old…tc/nsg))
  154.            (tc/nsd (bcopy old…tc/nsd))
  155.            (msk (bcopy old…msk))
  156.            (a->b (avancer…pd! rang tc/nsg tc/nsd msk (ccopy  old…a->b)))
  157.            (tc/nsg…etc (bcopy old…tc/nsg))
  158.            (tc/nsd…etc (bcopy old…tc/nsd))
  159.            (msk…etc (bcopy old…msk))
  160.            (a->b…etc (avancer…pg! rang tc/nsg…etc tc/nsd…etc msk…etc (ccopy old…a->b)))
  161.            (rangtt (explorer tc/nsg tc/nsd msk))
  162.            (fils (prouver…ts (1+ niveau) (bitmsk (pg (rangtt *tc*)) (pg a->b)) tc/nsg tc/nsd msk a->b))]
  163. {       (prin "***a***")
  164.        (prin (ppts (pg old…a->b)))
  165.        (prin "***b***")
  166.        (prin (ppts (pd old…a->b)))
  167.        (prin (ppts gamma))
  168.        (pause)}
  169.        (cond (not rang) ()
  170.              (eq? a->b †) (cond (eq? a->b…etc †) ()
  171.                                 (prouver…ts niveau (bitclr! gamma rang) tc/nsg…etc tc/nsd…etc msk…etc a->b…etc))
  172.              rangtt (cond (null? fils)
  173.                           (cond (eq? a->b…etc †) ()
  174.                                 (prouver…ts niveau (bitclr! gamma rang)
  175.                                             tc/nsg…etc tc/nsd…etc msk…etc a->b…etc))
  176.                           (eq? a->b…etc †) fils
  177.                           (append fils (prouver…ts niveau (bitclr! gamma rang)
  178.                                             tc/nsg…etc tc/nsd…etc msk…etc a->b…etc)))
  179.              (eq? a->b…etc †) (list a->b)
  180.              (cons a->b (prouver…ts niveau (bitclr! gamma rang) tc/nsg…etc tc/nsd…etc msk…etc a->b…etc)))))
  181.  
  182. {•••reclasse les clauses dans tc/nsg et tc/nsd,
  183.     en avancant dans tc/nsg (tc/nsd) les clauses qui contiennent le symbole en pg (pd) d'un cran,
  184.     en mettant a jour le msk ie eteindre les bits des clauses qui contiennent le symbole en pd (pg)
  185.     en appelant avancer…pg!ts pour les symboles s dans les clauses ->s qui sont ainsi apparues
  186.     en appelant avancer…pd!ts pour les symboles s dans les clauses s-> qui sont ainsi apparues
  187.     Elle travaille physiquement sur chacun des tableaux et retourne a->b}
  188.  
  189. (define (avancer…pg!ts ts tc/nsg tc/nsd msk a->b)
  190.   (letrec [(new…ts (bitand! (bitnot (pg a->b)) ts))
  191.            (tc…0sg (0 tc/nsg))
  192.            (tc…1sg (1 tc/nsg))
  193.            ((loop! rang ts tc/nsg)
  194.             (cond rang (begin (bitclr! ts rang) (bitand! (bitnot (pd (rang *tc/s*))) msk)
  195.                               (loop! (bitfind ts) ts (avancer!tc (bitand msk (pg (rang *tc/s*))) tc/nsg 0)))
  196.                   tc/nsg))
  197.            (new…tc/nsg (loop! (bitfind new…ts) new…ts tc/nsg))
  198.            (new…tc…->s (bitand! (1 tc/nsd) (bitmsk (0 new…tc/nsg) tc…0sg)))
  199.            (new…tsg (bitmsk (trouver…ts! pd (bitfind new…tc…->s) new…tc…->s) (pd a->b)))
  200.            (new…tc…s-> (bitand! (0 tc/nsd) (bitmsk (1 new…tc/nsg) tc…1sg)))
  201.            (new…tsd (bitmsk (trouver…ts! pg (bitfind new…tc…s->) new…tc…s->) (pg a->b)))]
  202.           (cond (eq? a->b †) †
  203.                 (not (bitfind new…ts)) a->b
  204.                 (bitfind (bitand ts (pd a->b))) †
  205.                 (begin (bitor! new…ts (pg a->b))
  206.                        (accede tc…0sg tc…1sg new…tsg new…tsd)
  207.                        (cond (bitfind (bitand (0 new…tc/nsg) (0 tc/nsd))) †
  208.                              (avancer…pg!ts new…tsg tc/nsg tc/nsd msk
  209.                                             (avancer…pd!ts new…tsd tc/nsg tc/nsd msk a->b)))))))
  210.            
  211. (define (avancer…pg! rang tc/nsg tc/nsd msk a->b)
  212.   (letrec [(tc…0sg (0 tc/nsg))
  213.            (tc…1sg (1 tc/nsg))
  214.            (new…tc/nsg (begin (bitand! (bitnot (pd (rang *tc/s*))) msk)
  215.                               (avancer!tc (bitand msk (pg (rang *tc/s*))) tc/nsg 0)))
  216.            (new…tc…->s (bitand! (1 tc/nsd) (bitmsk (0 new…tc/nsg) tc…0sg)))
  217.            (new…tsg (bitmsk (trouver…ts! pd (bitfind new…tc…->s) new…tc…->s) (pd a->b)))
  218.            (new…tc…s-> (bitand! (0 tc/nsd) (bitmsk (1 new…tc/nsg) tc…1sg)))
  219.            (new…tsd (bitmsk (trouver…ts! pg (bitfind new…tc…s->) new…tc…s->) (pg a->b)))]
  220.           (cond (eq? a->b †) †
  221.                 (rang (pd a->b)) †
  222.                 (rang (pg a->b)) a->b
  223.                 (begin (bitset! (pg a->b) rang)
  224.                        (accede tc…0sg tc…1sg new…tsg new…tsd)
  225.                        (cond (bitfind (bitand (0 new…tc/nsg) (0 tc/nsd))) †
  226.                              (avancer…pg!ts new…tsg tc/nsg tc/nsd msk
  227.                                       (avancer…pd!ts new…tsd tc/nsg tc/nsd msk a->b)))))))
  228.  
  229.  
  230. (define (avancer…pd!ts ts tc/nsg tc/nsd msk a->b)
  231.   (letrec [(new…ts (bitand! (bitnot (pd a->b)) ts))
  232.            (tc…0sd (0 tc/nsd))
  233.            (tc…1sd (1 tc/nsd))
  234.            ((loop! rang ts tc/nsd)
  235.             (cond rang (begin (bitclr! ts rang) (bitand! (bitnot (pg (rang *tc/s*))) msk)
  236.                               (loop! (bitfind ts) ts (avancer!tc (bitand msk (pd (rang *tc/s*))) tc/nsd 0)))
  237.                   tc/nsd))
  238.            (new…tc/nsd (loop! (bitfind new…ts) new…ts tc/nsd))
  239.            (new…tc…->s (bitand! (0 tc/nsg) (bitmsk (1 new…tc/nsd) tc…1sd)))
  240.            (new…tsg (bitmsk (trouver…ts! pd (bitfind new…tc…->s) new…tc…->s) (pd a->b)))
  241.            (new…tc…s-> (bitand! (1 tc/nsg) (bitmsk (0 new…tc/nsd) tc…0sd)))
  242.            (new…tsd (bitmsk (trouver…ts! pg (bitfind new…tc…s->) new…tc…s->) (pg a->b)))]
  243.           (cond (eq? a->b †) †
  244.                 (not (bitfind new…ts)) a->b
  245.                 (bitfind (bitand ts (pg a->b))) †
  246.                 (begin (bitor! ts (pd a->b))
  247.                        (accede tc…0sd tc…1sd new…tsg new…tsd)
  248.                        (cond (bitfind (bitand (0 tc/nsg) (0 new…tc/nsd))) †
  249.                              (avancer…pg!ts new…tsg tc/nsg tc/nsd msk
  250.                                       (avancer…pd!ts new…tsd tc/nsg tc/nsd msk a->b)))))))
  251.                               
  252.            
  253. (define (avancer…pd! rang tc/nsg tc/nsd msk a->b)
  254.   (letrec [(tc…0sd (0 tc/nsd))
  255.            (tc…1sd (1 tc/nsd))
  256.            (new…tc/nsd (begin (bitand! (bitnot (pg (rang *tc/s*))) msk)
  257.                               (avancer!tc (bitand msk (pd (rang *tc/s*))) tc/nsd 0)))
  258.            (new…tc…->s (bitand! (0 tc/nsg) (bitmsk (1 new…tc/nsd) tc…1sd)))
  259.            (new…tsg (bitmsk (trouver…ts! pd (bitfind new…tc…->s) new…tc…->s) (pd a->b)))
  260.            (new…tc…s-> (bitand! (1 tc/nsg) (bitmsk (0 new…tc/nsd) tc…0sd)))
  261.            (new…tsd (bitmsk (trouver…ts! pg (bitfind new…tc…s->) new…tc…s->) (pg a->b)))]
  262.           (cond (eq? a->b †) †
  263.                 (rang (pg a->b)) †
  264.                 (rang (pd a->b)) a->b
  265.                 (begin (bitset! (pd a->b) rang)
  266.                        (accede tc…0sd tc…1sd new…tsg new…tsd)
  267.                        (cond (bitfind (bitand (0 tc/nsg) (0 new…tc/nsd))) †
  268.                              (avancer…pg!ts new…tsg tc/nsg tc/nsd msk
  269.                                       (avancer…pd!ts new…tsd tc/nsg tc/nsd msk a->b)))))))
  270.  
  271. (define (avancer!tc tc tc/nxx n)
  272.   (cond (bitfind tc) (letrec [(ba (bitand tc ((1+ n) tc/nxx)))
  273.                               (tc…nxx (bitor ba (n tc/nxx)))]
  274.                              (accede tc…nxx)
  275.                              (cell=! tc/nxx n tc…nxx)
  276.                              (avancer!tc (bitmsk tc ba) tc/nxx (1+ n)))
  277.         tc/nxx))
  278.  
  279. {•••retourne le rang de la clause de tete entrainant le plus faible facteur de branchement ou ƒ}
  280.              
  281. (define (explorer tc/nsg tc/nsd msk)
  282.   (cond (bitfind (bitand msk (0 tc/nsd)))
  283.         (letrec [((loop n)
  284.                   (cond (>? n *nsmax*) ƒ
  285.                         (or (bitfind (bitand! (0 tc/nsd) (bitand msk (n tc/nsg)))) (loop (1+ n)))))]
  286.                 (loop 2))))
  287.  
  288. {••• retourne le tas de symboles apparaissant dans la partie goud des clauses de tc}
  289.  
  290. (define (trouver…ts! goud rang tc)
  291.   (cond rang (begin (bitclr! tc rang)
  292.                     (bitor! (goud (rang *tc*)) (trouver…ts! goud (bitfind tc) tc)))
  293.         (makebitarray *ns*)))
  294.  
  295. (define (clr!tc t goud a)
  296.   (let [(rang (bitfind a))]
  297.        (cond rang (begin (bitnot! (bitor! (goud (rang *tc/s*)) (bitnot! t)))
  298.                          (bitclr! a rang)
  299.                          (clr!tc t goud a))
  300.              t)))
  301.  
  302. (define (set!tc t goud a)
  303.   (let [(rang (bitfind a))]
  304.        (cond rang (begin (bitor! (goud (rang *tc/s*)) t)
  305.                          (bitclr! a rang)
  306.                          (set!tc t goud a))
  307.              (bitor! (goud (*ns* *tc/s*)) t))))
  308.  
  309. {•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••}
  310.  
  311. {••• projection de la partie goud d'une liste de feuilles d'échec sur une liste de symboles d'hypothèses}
  312. (define (proj…lfe pgoud ls lfe)
  313.   (letrec [(ts (traduire ls (makebitarray *ns*)))
  314.            ((loop l)
  315.             (cond (null? l) ()
  316.                   (cons (bitand ts (pgoud (0 l))) (loop (-1 l)))))]
  317.           (loop lfe)))
  318.  
  319. {••• pseudo produit cartésien d'une liste de tas de symboles}
  320. (define (pcart…lts lts)
  321.   (letrec [(ts (0 lts))
  322.            ((loop1 pcart)
  323.             (cond (null? pcart) ()
  324.                   (bitfind (bitand ts (0 pcart)))
  325.                   (cons (0 pcart) (loop1 (-1 pcart)))
  326.                   (pcart…2ts (bcopy ts) (0 pcart) (loop1 (-1 pcart)))))
  327.            ((pcart…2ts ts1 ts2 tas)
  328.             (letrec [((loop rang ts1)
  329.                       (cond rang (cons (bitset ts2 rang)
  330.                                        (begin (bitclr! ts1 rang) (loop (bitfind ts1) ts1)))
  331.                             tas))]
  332.                     (loop (bitfind ts1) ts1)))]
  333.           (cond (null? lts) ()
  334.                 (null? (-1 lts)) (pcart…2ts (0 lts) (makebitarray *ns*) ())
  335.                 (loop1 (pcart…lts (-1 lts))))))
  336.  
  337. (define rplacd cdr=!)
  338. (setstrict rplacd %11)
  339.  
  340. {••• minimisation par inclusion d'une liste de tas de symboles}
  341. (define (min!lts lts)
  342.   (cond (null? lts) ()
  343.         (letrec [((loop lp1)
  344.                   (cond (null? (-1 lp1)) (loop…suite lts)
  345.                         (not (bitfind (bitand! (0 lts) (bitnot (1 lp1)))))(loop (rplacd lp1 (-2 lp1)))
  346.                         (not (bitfind (bitand! (1 lp1) (bitnot (0 lts)))))(min!lts (-1 lts))
  347.                         (loop (-1 lp1))))
  348.                  ((loop…suite lp1)
  349.                   (cond (null? (-1 lp1)) lts
  350.                         (letrec [((loop…int lp2)
  351.                                   (cond (null? (-1 lp2)) (loop…suite (-1 lp1))
  352.                                         (not (bitfind (bitand! (1 lp1) (bitnot (1 lp2)))))
  353.                                         (loop…int (rplacd lp2 (-2 lp2)))
  354.                                         (not (bitfind (bitand! (1 lp2) (bitnot (1 lp1)))))
  355.                                         (loop…suite (rplacd lp1 (-2 lp1)))
  356.                                         (loop…int (-1 lp2))))]
  357.                                 (loop…int (-1 lp1)))))]
  358.                 (loop lts))))
  359.  
  360. {••• retire de lts1 les environnements qui incluent des environnements de lts2}
  361. (define (epurer lts1 lts2)
  362.   (letrec [((loop lts1)
  363.             (cond (null? lts1) ()
  364.                   (letrec [(ts (0 lts1))
  365.                            ((loop…int lts2)
  366.                             (cond (null? lts2) (cons ts (loop (-1 lts1)))
  367.                                   (bitfind (bitand! (0 lts2) (bitnot ts))) (loop…int (-1 lts2))
  368.                                   (loop (-1 lts1))))]
  369.                           (loop…int lts2))))]
  370.           (loop lts1)))
  371.  
  372. {••• En résumé pourles nogoods:
  373.      (define l…nogoods (min!lts (pcart…lts (proj…lfe pd l…hypotheses (• ()())))))
  374.      et pour les labels:
  375.      (epurer (min!lts (pcart…lts (• a b))) l…nogoods)}
  376.  
  377. {•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••}               
  378. {••• un pretty print pour le rang d'une clause}
  379.  
  380. (define (ppc rang)
  381.   (cond rang (let [(c (rang *tc*))]
  382.                   (cell (ppts (pg c)) (ppts (pd c))))
  383.         "Pas de regle"))
  384.  
  385. {••• un pretty print pour un vecteur de bits representant un ensemble de clauses}
  386.  
  387. (define (pptc p)
  388.   (letrec [(ba (bcopy p))
  389.            ((loop rang)
  390.             (cond rang (cond (>? rang *nc*) ()
  391.                              (begin (bitclr! ba rang) (cons (ppc rang) (loop (bitfind ba)))))
  392.                   ()))]
  393.           (loop (bitfind ba))))
  394.  
  395. {••• un pretty print pour le rang d'un symbole}
  396.  
  397. (define (pps rang)
  398.   (cond rang (rang *ts*) 
  399.         "Pas de symbole"))
  400.  
  401. {••• un pretty print pour un vecteur de bits representant un ensemble de symboles}
  402.  
  403. (define (ppts p)
  404.   (letrec [(ba (bcopy p))
  405.            ((loop rang)
  406.             (cond rang (begin (bitclr! ba rang) (cons (rang *ts*) (loop (bitfind ba))))
  407.                   ()))]
  408.           (loop (bitfind ba))))
  409.  
  410. {••• un pretty print pour une liste de vecteur de bits representant un ensemble de symboles}
  411.  
  412. (define (pplts lp)
  413.   (cond (null? lp) ()
  414.         (cons (ppts (0 lp)) (pplts (-1 lp)))))
  415.  
  416. {••• un pretty print pour les parties goud d'une liste de feuilles d'échec}
  417.  
  418. (define (pplfe pgoud lc)
  419.   (cond (null? lc) ()
  420.         (cons (ppts (pgoud (0 lc))) (pplfe pgoud (-1 lc)))))
  421.  
  422. (define (max n | l)
  423.   (cond (null? l) n
  424.         (<? n (0 l)) (apply max l)
  425.         (apply max (cons n (-1 l)))))
  426.  
  427. (defmacro (bitmsk x y)
  428.   `(bitand! ,x (bitnot! (bcopy ,y))))
  429.  
  430. (defmacro (bitand x y)
  431.   `(bitand! ,x (bcopy ,y)))
  432.  
  433. (defmacro (bitor x y)
  434.   `(bitor! ,x (bcopy ,y)))
  435.  
  436. (defmacro (bitnot x)
  437.   `(bitnot! (bcopy ,x)))
  438.  
  439. (defmacro (bitset x y)
  440.   `(bitset! (bcopy ,x) ,y))
  441.  
  442. (defmacro (ccopy a->b)
  443.   `(cell (bcopy (pg ,a->b)) (bcopy (pd ,a->b))))
  444.  
  445. {accede a la valeur d'une forme suspendue si la structure en est simple.
  446. Attention: Pour un cell, elle n'accede pas a chaque element}
  447.  
  448. (defmacro (accede | l)
  449.   (cons 'begin (maplist 'null? l)))
  450.  
  451. {Imprime en sequence par prin les elements de l et retourne la valeur du premier arg}
  452.  
  453. (defmacro (prinloop val | l)
  454.   `(begin ,@(maplist 'prin l) (flushio stdo) ,val))
  455.  
  456. {le stepper s'arrete pour les ident de variables, les cons, les fermetures}
  457.  
  458. (define (step? expr env)
  459.   (or (=? (type expr) 6)
  460.       (=? (type expr) 12)
  461.       (=? (type expr) 13)
  462.   ))
  463.  
  464. (let [(n 0)]
  465. (define (stepin expr env)
  466.   (=! n (1+ n))(prin n)(prin ">>>  ")
  467.   (print expr)
  468.   (print (envar env))
  469.   (pause) n))
  470.  
  471. (define (stepout n val)
  472.   (prin n)(prin "=  ")
  473.   (printdebug val)
  474.   (pause))
  475.  
  476. (define (maplist f l)
  477.   (cond (null? l) ()
  478.         (cons (list f (0 l)) (maplist f (-1 l)))))
  479.  
  480. {Instancifie une clause pg -> pd
  481.              Appeler: (instance '(list ib:x) '(list ib:z) '(ib:x ib:z) '((1 2)(a b)) '(<? ib:x 10))
  482.              Retourne:
  483. [(1) (a)]
  484. [(1) (b)]
  485. [(2) (a)]
  486. [(2) (b)]}
  487.  
  488. (define (instance pg pd lvar ldom test)
  489.   (letrec [((loopvar lvar ldom)
  490.             (cond (null? lvar) (cond (eval test ()) (print (cell (eval pg ()) (eval pd ()))))
  491.                   (loopval (0 lvar) (0 ldom) (-1 lvar) (-1 ldom))))
  492.            ((loopval var dom lvar ldom)
  493.             (cond (cons? dom) (begin (binding=! var () (0 dom))
  494.                                      (loopvar lvar ldom)
  495.                                      (loopval var (-1 dom) lvar ldom))))]
  496.           (loopvar lvar ldom)))
  497.  
  498. )
  499.  
  500.